Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/apptbk/apptbook.txt

Text File | 1993-01-06 | 19.2 KB | 696 lines

' Variables used to manage grid

Dim IgnoreRowChange As Integer
Dim GridInvertRect As RECT
Dim GridInverted As Integer
Dim GridDropRow As Integer

' Drag mode constants to keep track of dragging activity.

Dim DragType As Integer         ' type of object being dragged
Dim Dragging As Integer         ' TRUE when dragging is in progress
Dim DragIndex As Integer        ' Optional index of dragged obj
Dim DragRow As Integer          ' Optional row being dragged in grid

' Miscellaneous variables

Dim valid%                      ' used as return for DragValid

' Bitmasks to describe valid drag objects

Const MASK_NEWAPPT = 1      ' a new appointment
Const MASK_OLDAPPT = 2      ' an old appointment
Const MASK_NONE = 0         ' mask used where no drops are allowed

Function ApiRectFromPoint (ctl As Grid, X As Single, Y As Single, r As RECT) As Integer

    ' Given a grid control and a coordinate position, this routine
    ' returns a Windows RECT structure containing the pixel
    ' coordinates of the row being pointed at.  The row number is
    ' returned, or -1, indicating that no row is being pointed at.

    Dim curRow As Integer
    Dim totHeight As Single
    Dim topLocation As Single

    ' Loop through each row, accumulating row height until we reach
    ' the row containing the point.

    For curRow = 0 To ctl.Rows - 1

        topLocation = totHeight
        totHeight = totHeight + ctl.RowHeight(curRow) + Screen.TwipsPerPixelY

        If Y < totHeight Then

            ' Convert the twips values into pixel coordinates

            ApiRectFromPoint = curRow

            r.top = topLocation / Screen.TwipsPerPixelY
            r.bottom = totHeight / Screen.TwipsPerPixelY
            r.left = 0
            r.right = ctl.Width / Screen.TwipsPerPixelY

            Exit Function

        End If

    Next curRow

    ApiRectFromPoint = -1           ' indicate failure

End Function

Sub ApptEdit ()

    ' This subroutine moves the data in the current grid row into
    ' the "post-it" editing area.

    Dim aText As String
    Dim colonPos As Integer

    ' This routine copies appointment data to the edit window

    ApptList.Col = 1

    aText = ApptList.Text
    colonPos = InStr(aText, ":")

    ' If no colon, there's no appointment, so clear the post-it
    ' area.  If there is a colon, fill in the information.

    If colonPos = 0 Then
        ApptText.Text = ""
        ApptTime.Text = Format$(0, ApptTime.Format)
        ApptType.Text = ""
    Else
        ApptType.Text = Left$(aText, colonPos - 1)
        ApptText.Text = Mid$(aText, colonPos + 2)
        ApptList.Col = 0
        ApptTime.Text = Format$(ApptList.Text, ApptTime.Format)
    End If

End Sub

Sub ApptList_DragDrop (Source As Control, X As Single, Y As Single)

    ' Drop a new appointment or existing appointment at a new
    ' row position.

    Dim aText As String
    Dim i%

    If Not EndDragMode(MASK_NEWAPPT Or MASK_OLDAPPT) Then Exit Sub

    UnhighlightRow
    IgnoreRowChange = True

    If DragType = MASK_NEWAPPT Then
        ApptList.Col = 1
        ApptList.Row = GridDropRow
        ApptList.Text = Source.Tag & ": "
        ApptEdit
    Else
        ApptList.Col = 0
        ApptList.Row = GridDropRow
        aText = ApptList.Text
        ApptList.Row = DragRow
        i% = ChangeApptTime(TimeValue(aText))
    End If

    IgnoreRowChange = False
    ApptText.SetFocus

End Sub

Sub ApptList_DragOver (Source As Control, X As Single, Y As Single, State As Integer)

    ' When dragging over the grid, both new and old appointments
    ' are considered.  For both cases, we unhighlight the current
    ' destination row upon leaving the drop zone, and assure that
    ' the row under the point is highlighted otherwise.

    If Not DragValid(Source, MASK_NEWAPPT Or MASK_OLDAPPT, State) Then
        Exit Sub
    End If

    Select Case State
        Case LEAVE
            UnhighlightRow
        Case Else
            GridDropRow = HighlightRowAtPoint(X, Y)
    End Select

End Sub

Sub ApptList_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' We take charge of the mouse down event to initiate dragging
    ' ourselves.  First, the cursor must be in column 1.  Next,
    ' the row must contain a valid appointment to be grabbed
    ' (identified by the presence of a colon in the cell).

    If AtGridCol(ApptList, X, Y) > 0 Then
        If InStr(ApptList.Text, ":") <> 0 Then

            ' The timer will now count down.  This allows the user
            ' to easily click, or "press" the mouse.  The Timer
            ' event handles the drag initialization.

            GridTimer.Enabled = True

        End If
    End If

End Sub

Sub ApptList_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' Be sure the timer is disabled so that a click doesn't
    ' initiate a drag.  If it's already disabled, it doesn't matter.

    GridTimer.Enabled = False

End Sub

Sub ApptList_RowColChange ()

    ' Whenever the row changes, move the highlight to track the
    ' current cell.

    ApptList.SelStartRow = ApptList.Row
    ApptList.SelEndRow = ApptList.Row

    ' IgnoreRowChange means that we're setting Col or Row somewhere
    ' else in the code and we don't want ApptEdit to be called.
    ' Otherwise, the user changed the row and we update the
    ' "post-it" area.

    If Not IgnoreRowChange Then
        IgnoreRowChange = True
        ApptEdit
        IgnoreRowChange = False
    End If

End Sub

Sub ApptText_DragDrop (Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub ApptText_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Sub ApptTime_DragDrop (Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub ApptTime_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Sub ApptTime_ValidationError (InvalidText As String, StartPosition As Integer)

    MsgBox "Invalid time"
    ApptTime.SetFocus

End Sub

Sub ApptType_DragDrop (Source As Control, X As Single, Y As Single)

    ' Accept a drop only for a NEWAPPT icon, otherwise the
    ' operation will be cancelled.

    If EndDragMode(MASK_NEWAPPT) Then
        ApptType.Text = Source.Tag
    End If

End Sub

Sub ApptType_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NEWAPPT, State)
End Sub

Sub ApptType_KeyPress (KeyAscii As Integer)

    ' Don't allow a colon to be entered, since we use a colon to
    ' separate the appointment "kind" from the text.

    If KeyAscii = Asc(":") Then
        Beep
        KeyAscii = 0
    End If

End Sub

Function AtGridCol (ctl As Control, X As Single, Y As Single)

    ' Given a point on a grid control, in twips, this routine
    ' returns the column number where the point is located, or
    ' -1 indicating the point is outside the grid.

    Dim curCol As Integer
    Dim totWidth As Single

    ' Loop through each column, accumulating column width until we
    ' reach the column containing the point.

    For curCol = 0 To ctl.Cols - 1

        totWidth = totWidth + ctl.ColWidth(curCol) + Screen.TwipsPerPixelX

        If X < totWidth Then
            AtGridCol = curCol
            Exit Function
        End If

    Next curCol

    AtGridCol = -1          ' not found

End Function

Sub BeginDragMode (ctl As Control, objType As Integer)

    ' Whenever a drag is about to start, this routine is called.
    ' The type mask of the drag is flagged, and we remember that
    ' dragging is in progress.   This routine MUST be matched
    ' by an EndDragMode function call.

    DragType = objType
    Dragging = True

    ' Start the drag process

    ctl.Drag BEGIN_DRAG

End Sub

Function ChangeApptTime (newtime As Variant) As Integer

    ' Given a new time for an appointment at the current row, this
    ' routine moves the appointment to the new location in the
    ' grid.

    Dim trow As Integer
    Dim oldAppt As String

    trow = TimeRow(newtime)

    ' If we're already there, then do nothing and return False,
    ' indicating no row change occurred.

    If trow = ApptList.Row Then
        ChangeApptTime = False
        Exit Function
    End If

    ChangeApptTime = True
    IgnoreRowChange = True

    ' Actually move the row.

    ApptList.Col = 1
    oldAppt = ApptList.Text
    ApptList.Text = ""

    ApptList.Row = trow
    ApptList.Text = oldAppt

    ApptEdit            ' move the data to the post-it area

    IgnoreRowChange = False

End Function

Function DragValid (src As Control, mask As Integer, State As Integer) As Integer

    ' This function is called by an object's DragOver event to
    ' automatically change the drag cursor to the "no drop"
    ' cursor if necessary.  It also returns True if the object
    ' can legally be dropped according to the input mask.

    If (mask And DragType) Then
        DragValid = True
        Exit Function
    End If

    ' This is not a valid drag.  Return False, but also change the
    ' object's drag icon to the NoDrag icon (remembering the old
    ' value for later restore when we exit this object).

    DragValid = False

    Select Case State

        Case ENTER

            ' Entering, remember old icon

            SaveIcon.DragIcon = src.DragIcon
            src.DragIcon = NoDrag.DragIcon

        Case LEAVE

            ' Exiting, restore old icon

            src.DragIcon = SaveIcon.DragIcon

    End Select

End Function

Function EndDragMode (mask As Integer) As Integer

    ' This function is called when a drag has ended, either
    ' successfully or unsuccessfully.  This routine removes any
    ' user feedback related to the drag operation and returns
    ' TRUE if the passed mask matches the dragged object.

    Select Case DragType

        Case MASK_NEWAPPT

            ' If a "new appointment" icon was dragged, change the
            ' frame background to LTGREY again so that the drag
            ' is officially over.

            KindFrame(DragIndex).BackColor = LTGREY

        Case MASK_OLDAPPT

            ' If this is an item dragged from the grid, refresh
            ' the grid in case the drag ended outside the grid
            ' frame (and the inverted row remains).

            ApptList.Refresh

    End Select

    Dragging = False
    EndDragMode = (mask And DragType) <> 0

End Function

Sub Form_DragDrop (Source As Control, X As Single, Y As Single)

    ' Ignore drops which occur on the form

    valid% = EndDragMode(MASK_NONE)

End Sub

Sub Form_DragOver (Source As Control, X As Single, Y As Single, State As Integer)

    ' Assure that the "no drop" icon is displayed when passing
    ' over the form.

    valid% = DragValid(Source, MASK_NONE, State)

End Sub

Sub Form_Load ()

    Dim curTime As Variant
    Dim curRow As Integer
    Dim rowMax As Integer

    ' Initialize the grid column widths, and set the height of
    ' the list so it displays all times entered.

    rowMax = (Prefs.timeEnd - Prefs.timeStart) / Prefs.timeIncrement
    ApptList.ColWidth(0) = ApptForm.TextWidth("XX:XX XX")
    ApptList.ColWidth(1) = ApptList.Width - ApptList.ColWidth(0)

    ApptList.Height = (ApptList.RowHeight(0) + Screen.TwipsPerPixelY) * rowMax

    IgnoreRowChange = True

    ApptList.Rows = rowMax
    ApptList.Col = 0

    ' Fill the leftmost column with appointment times.

    For curTime = Prefs.timeStart To Prefs.timeEnd Step Prefs.timeIncrement
        ApptList.Row = curRow
        ApptList.Text = Format$(curTime, "hh:mm am/pm")
        curRow = curRow + 1
    Next curTime

    IgnoreRowChange = False
    ApptList.Row = 0

End Sub

Sub Form_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' Since we can't trap a "drop" which occurs outside of our
    ' application, this is a pretty good solution.  Whenever the
    ' cursor passes over the form, if we're still dragging check
    ' to see if the button is now up.  If so, just cancel the
    ' operation

    If Dragging Then
        If (Button And LEFT_BUTTON) = 0 Then
            valid% = EndDragMode(MASK_NONE)
        End If
    End If

End Sub

Sub GridTimer_Timer ()

    ' When the timer is triggered, the user has been holding the
    ' mouse down over a grid row for a "press" duration.  Now,
    ' initiate a drag operation.

    ' Reset the column to the one with the text in it.

    IgnoreRowChange = True
    ApptList.Col = 1
    IgnoreRowChange = False

    ' Indicate we're doing an "old appointment" drag.

    DragRow = ApptList.Row
    ApptList.DragIcon = MoveIcon.DragIcon
    BeginDragMode ApptList, MASK_OLDAPPT
    GridTimer.Enabled = False

End Sub

Function HighlightRowAtPoint (X As Single, Y As Single) As Integer

    ' If the ApplList grid was highlighted (according to the
    ' GridInverted variable), then unhighlight the old location and
    ' highlight the new one.  Instead of a row number, a point within
    ' the grid is passed.  The row number is returned, or -1, meaning
    ' that the point was outside the grid.

    Dim newrect As RECT
    Dim rownum As Integer
    Dim gridDC As Integer

    rownum = ApiRectFromPoint(ApptList, X, Y, newrect)
    HighlightRowAtPoint = rownum

    ' Don't rehighlight the current row, just exit.

    If rownum >= 0 And GridInverted And newrect.top = GridInvertRect.top Then Exit Function

    ' Use the Windows API call InvertRect to invert the row we're
    ' passing above.

    gridDC = GetDC(ApptList.hWnd)

    If GridInverted Then InvertRect gridDC, GridInvertRect
    GridInverted = True

    If rownum >= 0 Then
        GridInvertRect = newrect
        InvertRect gridDC, GridInvertRect
        GridInverted = True
    Else
        GridInverted = False
    End If

    gridDC = ReleaseDC(ApptList.hWnd, gridDC)

End Function

Sub Image1_DragDrop (Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub Image1_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Sub KindFrame_DragDrop (Index As Integer, Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub KindFrame_DragOver (Index As Integer, Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NEWAPPT, State)
End Sub

Sub KindPict_DragDrop (Index As Integer, Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub KindPict_DragOver (Index As Integer, Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NEWAPPT, State)
End Sub

Sub KindPict_MouseDown (Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

    ' When the left button goes down over an "appointment type"
    ' icon, drag its image in NEWAPPT mode.  Copy the DragIcon
    ' each time, since it may still be set to the "no drop" icon
    ' from a previous cancellation.

    If Button And LEFT_BUTTON Then

        KindFrame(Index).DragIcon = DragArrow.DragIcon
        BeginDragMode KindFrame(Index), MASK_NEWAPPT
        KindFrame(Index).BackColor = CYAN

        ' Save the index, we'll need it in EndDragMode

        DragIndex = Index

    End If

End Sub

Sub Label1_DragDrop (Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub Label1_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Sub Label2_DragDrop (Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub Label2_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Sub Panel3D1_DragDrop (Source As Control, X As Single, Y As Single)
    valid% = EndDragMode(MASK_NONE)
End Sub

Sub Panel3D1_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Sub SaveButton_Click ()

    ' Save all data in the post-it area to the grid.

    Dim i%

    IgnoreRowChange = True
    ApptList.Col = 1

    ' We can only save if there's an appointment on the current
    ' grid row already (at least a blank one).

    If InStr(ApptList.Text, ":") = 0 Then
        MsgBox "No appointment at current row"
        Exit Sub
    End If

    ApptList.Text = ApptType.Text & ": " & ApptText.Text
    IgnoreRowChange = False

    ' If the time was changed manually, then move the row to the new
    ' location.

    i% = ChangeApptTime(TimeValue(ApptTime.Text))

End Sub

Sub SaveButton_DragOver (Source As Control, X As Single, Y As Single, State As Integer)
    valid% = DragValid(Source, MASK_NONE, State)
End Sub

Function TimeRow (thetime As Variant) As Integer

    ' Given a time value, return the row number within the grid
    ' where the specified time slot is located.

    TimeRow = (thetime - Prefs.timeStart) / Prefs.timeIncrement

End Function

Sub TrashCan_DragDrop (Source As Control, X As Single, Y As Single)

    ' The trash can only accepts drops for "old appointments" from
    ' the grid.

    If EndDragMode(MASK_OLDAPPT) Then

        ' Get rid of feedback

        TrashCan.Picture = TrashClosed.Picture

        ' Clear the grid row and update the post-it area

        IgnoreRowChange = True

        ApptList.Row = DragRow
        ApptList.Col = 1
        ApptList.Text = ""
        ApptEdit
        ApptList.SetFocus

        IgnoreRowChange = False

    End If

End Sub

Sub TrashCan_DragOver (Source As Control, X As Single, Y As Single, State As Integer)

    ' Provide feedback by "opening the trashcan" whenever an
    ' old appointment is dragged over the trash.

    If DragValid(Source, MASK_OLDAPPT, State) Then
        Select Case State
            Case ENTER
                ' Open when entering
                TrashCan.Picture = TrashOpened.Picture
            Case LEAVE
                ' Close when leaving
                TrashCan.Picture = TrashClosed.Picture
        End Select
    End If
End Sub

Sub UnhighlightRow ()

    ' If the ApptList grid is highlighted (according to the
    ' GridInverted flag), then unhighlight it, otherwise do
    ' nothing.

    Dim gridDC As Integer

    If Not GridInverted Then Exit Sub

    ' Use the invert rectangle saved by HighlightRowAtPoint

    gridDC = GetDC(ApptList.hWnd)
    InvertRect gridDC, GridInvertRect
    gridDC = ReleaseDC(ApptList.hWnd, gridDC)

    GridInverted = False

End Sub